home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Fred (editor) utilities.sea / Fred (editor) utilities / fill-paragraph.lisp < prev    next >
Encoding:
Text File  |  1993-02-26  |  29.7 KB  |  635 lines  |  [TEXT/CCL2]
  1. ;;; -*- Package: CL-USER -*-
  2.  
  3. ;;; Fill paragraph (m-Q)
  4.  
  5. ;;; Version 1/27/93
  6. ;;; Please report bugs and improvements to Carl Gay (cgay@cs.uoregon.edu).
  7. ;;; Feel free to do whatever you want with this code.
  8.  
  9. ;;; Change Log:
  10. ;;; 1/25/93 Released to unsuspecting users.  CGay
  11. ;;; 1/27/93 Removed use of #. which was blowing out during compile-file.
  12.  
  13.  
  14. ;;; The code in this file implements emacs-like text filling (a la m-Q)
  15. ;;;
  16. ;;; The main commands and their default key bindings are:
  17. ;;;
  18. ;;; ED-FILL-PARAGRAPH (m-Q) -
  19. ;;; Fill the "paragraph" surrounding the cursor.  A paragraph is defined as
  20. ;;; the current Lisp comment, if the cursor is in a Lisp comment, or
  21. ;;; otherwise an attempt is made to heuristicate the text paragraph
  22. ;;; surrounding the cursor.  See the function paragraph-bounds for more
  23. ;;; details.  With a numeric arg, fills the region.  If *fill-justification*
  24. ;;; is non-NIL this will do justification at the same time.
  25. ;;;
  26. ;;; ED-SET-FILL-COLUMN (c-X f) -
  27. ;;; Set the fill column to the current cursor column.  With c-U, set it to
  28. ;;; *default-fill-column* (below).  With a numeric argument, set it to that
  29. ;;; argument.
  30. ;;;
  31. ;;; ED-SET-FILL-PREFIX (c-X .) -
  32. ;;; Set *fill-prefix* to the text preceding the cursor on the current line.
  33. ;;; If the cursor is at the beginning of the line, cancel the fill prefix.
  34. ;;;
  35. ;;; ED-JUSTIFY-PARAGRAPH (c-X j) -
  36. ;;; Justify the current paragraph.  Still has some major bugs, be ye forewarned.
  37. ;;;
  38. ;;; *FILL-COLUMN* -
  39. ;;; A number specifying the column past which text should not extend.
  40. ;;;
  41. ;;; *DEFAULT-FILL-COLUMN* -
  42. ;;; The value of *fill-column* is restored from this when ed-set-fill-column
  43. ;;; is invoked with a c-U argument.
  44. ;;;
  45. ;;; *FILL-PREFIX* -
  46. ;;; A string, NIL or a function.  The default is NIL.  See
  47. ;;; lisp-comment-fill-prefix for an example of the kind of function
  48. ;;; required. 
  49. ;;;
  50. ;;; *FILL-JUSTIFICATION* -
  51. ;;; Type of text justification to do. NIL (the default, meaning don't
  52. ;;; justify at all) or :LEFT, :RIGHT, :CENTER or :FULL, with the "obvious"
  53. ;;; meanings.  :full seems to work well.  I didn't test the others much, and
  54. ;;; thought about just deleting them...
  55. ;;;
  56. ;;; *AUTO-FILL-ENABLED* -
  57. ;;; Whether or not to automatically fill at the end of a line during normal
  58. ;;; typing.  t, nil, or :lisp-comments.  Mostly tested with :lisp-comments.
  59. ;;;
  60. ;;; *FILL-SENTENCE-DELIMITERS* -
  61. ;;; A list of characters after which two spaces (instead of one) should be
  62. ;;; inserted.  The default is '(#\. #\? #\!).  Some people may want to add
  63. ;;; colon (:) to this list.
  64. ;;;
  65. ;;; To do:
  66. ;;; - Make justify-paragraph undoable.
  67. ;;; - If an error occurs during fill, restore buffer to original state (Undo)
  68. ;;; when the user aborts.
  69. ;;; - Make deletion of empty comment lines, e.g. ";;; <CR>", optional.  This
  70. ;;; could probably be done best by modifying fill-prefix-region-bounds.  Default to no
  71. ;;; deletion.
  72. ;;; - Make regularizing the spacing between words optional.
  73. ;;; - Make fill redoable.
  74. ;;; - Allow filling at other chars besides whitespace (e.g., at hyphens)
  75. ;;;
  76. ;;; Bugs:
  77. ;;; - Justification code is still screwy.  :center justification in
  78. ;;; particular.  If invoked on the same paragraph several times in a row the
  79. ;;; paragraph keeps moving to the right.  :-) Low priority.  Who's gonna use
  80. ;;; this anyway?
  81. ;;; - Doesn't always deal with fonts correctly.  (see calls to buffer-insert)
  82. ;;; - Probably lots of others I can't remember right now.
  83. ;;; - Some of the global vars should be on a per-buffer basis. e.g., buffer
  84. ;;; properties.  In particular *auto-fill-enabled*.
  85.  
  86. ;;; Search for +++ to find things that need fixing.
  87.  
  88.  
  89. (defparameter *default-fill-column* 76)
  90. (defvar *fill-column* *default-fill-column*)
  91. (defvar *fill-justification* nil)
  92. (defvar *fill-prefix* nil)
  93. (defparameter *auto-fill-enabled* :lisp-comments)
  94. (defparameter *fill-sentence-delimiters* (list #\. #\? #\!))
  95. (defparameter *fill-whitespace* (coerce '(#\space #\tab #\page #\linefeed) 'string))
  96. (defparameter *fill-whitespace&cr* (concatenate 'string *fill-whitespace*
  97.                                                     (string #\Return)))
  98.  
  99. ;;; Dynamically scoped numeric arg.
  100. (defvar *numeric-arg* nil)
  101.  
  102. (defmacro with-numeric-arg ((window &optional allow-control-u) &body body)
  103.   `(let ((*numeric-arg* (slot-value ,window 'ccl::prefix-argument)))
  104.      (when (and (not ,allow-control-u) (consp *numeric-arg*))
  105.        (setq *numeric-arg* (car *numeric-arg*)))
  106.      . ,body))
  107.  
  108. (defmethod run-fred-command :around ((w fred-mixin) arg)
  109.   (declare (ignore arg))
  110.   (with-numeric-arg (w :allow-control-u)
  111.     (call-next-method)))
  112.  
  113. ;;; A few fewer chars to type.
  114. (defmacro bpos (buffer)
  115.   `(buffer-position ,buffer))
  116.  
  117. ;;; An abbreviation for a common idiom.
  118. (defun skip-whitespace (buffer start end &optional cr-too from-end)
  119.   (buffer-not-char-pos buffer (if cr-too *fill-whitespace&cr* *fill-whitespace*)
  120.                        :start start :end end :from-end from-end))
  121.  
  122. ;;; This will be right 99.9% of the time.
  123. (defun in-lisp-comment-p (buffer &optional position)
  124.   (let ((c (skip-whitespace buffer
  125.                             (buffer-line-start buffer position)
  126.                             (buffer-line-end buffer position))))
  127.     (values (and c (char-equal (buffer-char buffer c) #\;))
  128.             c)))
  129.  
  130. ;;; Find the bounds of the text surrounding the cursor that begins with the
  131. ;;; current fill prefix.
  132. ;;; Probably a better way.
  133. (defun fill-prefix-region-bounds (buffer)
  134.   (do ((i 0 (+ i 1)) (start) (end) (b) (f))
  135.       ()
  136.     (multiple-value-bind (bol-backward shortfallp)      ; Dylan, take me away!
  137.                          (buffer-line-start buffer nil (- i))
  138.       (multiple-value-bind (eol-forward longfallp)
  139.                            (buffer-line-end buffer nil i)
  140.         (setq b (and (or (zerop i) b)
  141.                      (not shortfallp)
  142.                      (fill-prefix-exists-p buffer bol-backward)))
  143.         (setq f (and (or (zerop i) f)
  144.                      (not longfallp)
  145.                      (fill-prefix-exists-p buffer eol-forward)))
  146.         (when (and (null b) (null f))
  147.           (return (values start end)))
  148.         (when b (setq start bol-backward))
  149.         (when f (setq end eol-forward))))))
  150.  
  151. ;;; Find the bounds of the "paragraph" surrounding the cursor.
  152. (defun paragraph-bounds (window)
  153.   (let ((buffer (fred-buffer window))
  154.         ;; +++ Internal.  May lose in the future.
  155.         (mark (caar (slot-value window 'ccl::mark-ring))))
  156.     (cond (*numeric-arg*                ; Fill the region.
  157.            (if (or (null mark)
  158.                    (= (bpos mark) (bpos buffer)))
  159.              ;; +++ This should do something better than error.
  160.              (error "Can't fill the region because no region was specified.")
  161.              (values (min (bpos mark) (bpos buffer))
  162.                      (max (bpos mark) (bpos buffer)))))
  163.           ;; Fill the region delimited by the current fill prefix.
  164.           (*fill-prefix*
  165.            (fill-prefix-region-bounds buffer))
  166.           (t                            ; Fill plain text.
  167.            (text-bounds buffer)))))
  168.  
  169. ;;; Stub.  +++ This needs to take the fill-prefix into account.
  170. (defun text-bounds (buffer)
  171.   (let ((start 0)
  172.         (end (- (buffer-size buffer) 1)))
  173.     ;; Find the closest paragraph separator after the cursor.
  174.     (dolist (separator '#.(list (format nil "~2%")
  175.                                 (format nil "|#")))
  176.       (let ((pos (buffer-string-pos buffer separator
  177.                                     :start (bpos buffer))))
  178.         (and pos (setq end (min end pos)))))
  179.     ;; Find the closest paragraph separator before the cursor.
  180.     (dolist (separator '#.(list (format nil "~2%")
  181.                                 (format nil "#|")))
  182.       (let ((pos (buffer-string-pos buffer separator :start 0
  183.                                     :end (bpos buffer) :from-end t)))
  184.         (and pos (setq start (max start (+ pos (length separator)))))))
  185.     ;; For now don't try to fill plain-text comments contained within
  186.     ;; a top-level definition.
  187.     (let ((def-start (buffer-string-pos buffer #.(format nil "~%(")
  188.                                         :end (bpos buffer) :from-end t)))
  189.       (when def-start
  190.         (multiple-value-bind (sexp-start sexp-end)
  191.                              (buffer-current-sexp-bounds buffer (+ def-start 1))
  192.           (when (and sexp-start sexp-end
  193.                      (<= sexp-start (bpos buffer) sexp-end))
  194.             ;; +++ This shouldn't err.
  195.             (error "Can't fill a top-level definition.")))))
  196.     #+ignore
  197.     (loop for i from start to end do (princ (buffer-char buffer i)))
  198.     (values start end *fill-prefix*)))
  199.  
  200. ;;; Determine the length of the fill prefix on the line containing POSITION.
  201. (defun fill-prefix-length (buffer &optional position)
  202.   (operate-on-fill-prefix buffer position :length
  203.                           #'(lambda ()
  204.                               (if *fill-prefix* (length *fill-prefix*) 0))))
  205.  
  206. (defun lisp-comment-fill-prefix (buffer position operation &optional ppend)
  207.   (declare (ignore ppend))              ; No longer used.
  208.   (when (null position) (setq position (bpos buffer)))
  209.   (let (
  210.         ;; If we're computing the length of the fill prefix then we need to
  211.         ;; look at the beginning of the line to see what's there.  If we're
  212.         ;; trying to skip over the fill prefix then POSITION should already
  213.         ;; be pointing to the beginning of the fill prefix.
  214.         (start (if (member operation '(:exists-p :length))
  215.                  (buffer-line-start buffer position)
  216.                  position))
  217.         (eol (buffer-line-end buffer position)))
  218.     (ecase operation
  219.       (:insert
  220.        ;; This is schrod.  <- (I don't remember why I wrote that.)
  221.        ;; Maybe I can just get the indentation from the previous line???
  222.        (let* ((begin (buffer-string-pos buffer #.(format nil "~%(")
  223.                                         :end position :from-end t))
  224.               ;; ccl::lisp-indentation apparently returns a position that is
  225.               ;; at the correct indentation column for this line.
  226.               (pos (and begin (ccl::lisp-indentation buffer begin position)))
  227.               (col (and pos (buffer-column buffer pos))))
  228.          (if (and col (> col 0))
  229.            (progn (dotimes (i col)
  230.                     (buffer-insert buffer " " position))
  231.                   (buffer-insert buffer ";; " (+ position col)))
  232.            (buffer-insert buffer ";;; " position))))
  233.       (:length
  234.        (let ((x (buffer-not-char-pos buffer *fill-whitespace*
  235.                                      :start start :end eol)))
  236.          (setq x (buffer-not-char-pos buffer ";"
  237.                                       :start (or x start) :end eol))
  238.          (if (not x) 0 (- x start))))
  239.       (:skip
  240.        ;; Skip the fill prefix.  Note that this assumes a fill prefix exists
  241.        ;; on this line.
  242.        (let ((x (buffer-not-char-pos
  243.                  buffer ";"
  244.                  :start (buffer-not-char-pos buffer *fill-whitespace*
  245.                                              :start start :end eol)
  246.                  :end eol)))
  247.          (if (null x)
  248.            eol
  249.            ;; It ends one space after the semicolons.
  250.            (if (char-equal #\space (buffer-char buffer x))
  251.              (+ x 1)
  252.              x))))
  253.       (:exists-p
  254.        ;; Find out if the current line already contains a fill prefix.
  255.        (let ((pos (skip-whitespace buffer start eol)))
  256.          (and pos (char-equal (buffer-char buffer pos) #\;))))
  257.       )))
  258.  
  259. (defun whitespace-fill-prefix (buffer position operation &optional ppend)
  260.   (unless ppend
  261.     (setq ppend (buffer-line-end buffer position)))
  262.   (ecase operation
  263.     (:insert)
  264.     (:skip (skip-whitespace buffer position ppend))
  265.     (:length (let ((bol (buffer-line-start buffer position)))
  266.                (- (skip-whitespace buffer bol ppend) bol)))
  267.     (:exists-p (find (buffer-char buffer (buffer-line-start buffer position))
  268.                      *fill-whitespace* :test #'char-equal))))
  269.  
  270. (defun fill-prefix (buffer position)
  271.   (if (in-lisp-comment-p buffer position)
  272.     'lisp-comment-fill-prefix
  273.     *fill-prefix*))
  274.  
  275. ;;; Find the position of the beginning of the next word, skipping whitespace
  276. ;;; and fill prefix.  Can return NIL if no next word found.
  277. (defun find-next-word (buffer-mark start end)
  278.   ;; If we're already in a word, just return START.
  279.   (if (not (find (buffer-char buffer-mark start) *fill-whitespace&cr*
  280.                  :test #'char-equal))
  281.     start
  282.     (if (null *fill-prefix*)
  283.       (skip-whitespace buffer-mark start end :cr-too)
  284.       (loop with pos = start do
  285.             (setq pos (skip-whitespace buffer-mark pos end))
  286.             (if (and pos
  287.                      (char-equal (buffer-char buffer-mark pos) #\Return))
  288.               ;; Found a #\Return, so skip the fill prefix if any.
  289.               (progn (incf pos)
  290.                      ;; Need to deal with the possibility that we could be
  291.                      ;; past END here...
  292.                      (setq pos (skip-over-fill-prefix buffer-mark pos end))
  293.                      (when (or (null pos)
  294.                                (not (find (buffer-char buffer-mark pos)
  295.                                           *fill-whitespace*
  296.                                           :test #'char-equal)))
  297.                        (return pos)))
  298.               ;; Otherwise, we're at the beginning of a word.
  299.               (return pos))))))
  300.  
  301. ;;; Called with POSITION pointing to the beginning of a line in BUFFER.
  302. ;;; This must return the position of the character immediately following
  303. ;;; the fill prefix, or POSITION if it determines that there is no fill
  304. ;;; prefix starting at POSITION.
  305. (defun skip-over-fill-prefix (buffer position ppend)
  306.   (operate-on-fill-prefix
  307.    buffer position :skip
  308.    ;; The default behavior for when *fill-prefix* is a string.
  309.    #'(lambda ()
  310.        (if (null *fill-prefix*)
  311.          position
  312.          (let ((prefix-end (+ position (length *fill-prefix*))))
  313.            (if (>= prefix-end (buffer-size buffer))
  314.              nil
  315.              ;; This could use buffer-substring-p if we didn't care about
  316.              ;; alphabetic case.
  317.              (if (loop for i from position
  318.                        for j from 0
  319.                        while (< j (length *fill-prefix*))
  320.                        as c = (char *fill-prefix* j)
  321.                        do (unless (char= c (buffer-char buffer i))
  322.                             (return nil))
  323.                        finally (return t))
  324.                prefix-end
  325.                position)))))
  326.    ppend))
  327.  
  328. (defun operate-on-fill-prefix (buffer position operation function &rest args)
  329.   (cond ((null *fill-prefix*)
  330.          (apply 'whitespace-fill-prefix buffer position operation args))
  331.         ((stringp *fill-prefix*)
  332.          (funcall function))
  333.         ((or (functionp *fill-prefix*)
  334.              (symbolp *fill-prefix*))
  335.          (apply *fill-prefix* buffer position operation args))))
  336.  
  337. ;;; Determine whether the line at buffer/position has a fill prefix already.
  338. ;;; This is only used to decide whether to insert the fill prefix on the
  339. ;;; first line of the fill area.
  340. (defun fill-prefix-exists-p (buffer position)
  341.   (operate-on-fill-prefix
  342.    buffer position :exists-p
  343.    #'(lambda ()
  344.        (when *fill-prefix*
  345.          (loop with eol =  (buffer-line-end buffer position)
  346.                for j from 0
  347.                while (< j (length *fill-prefix*))
  348.                as char = (char *fill-prefix* j)
  349.                for pos from (buffer-line-start buffer position)
  350.                do (when (or (>= pos eol)
  351.                             (not (char= char (buffer-char buffer pos))))
  352.                     (return nil))
  353.                finally (return t))))))
  354.  
  355. (defun insert-fill-prefix (buffer-mark &optional position insert-cr)
  356.   (when insert-cr
  357.     (buffer-insert buffer-mark #\Return position)
  358.     (incf position))
  359.   (operate-on-fill-prefix
  360.    buffer-mark position :insert
  361.    #'(lambda ()
  362.        (when *fill-prefix*
  363.          (buffer-insert buffer-mark *fill-prefix*
  364.                         (or position (bpos buffer-mark)))))))
  365.  
  366. (defmethod ed-set-fill-prefix ((window fred-mixin))
  367.   (let ((b (fred-buffer window)))
  368.     (if (zerop (buffer-column b))
  369.       (progn (setq *fill-prefix* nil)
  370.              (set-mini-buffer window "Fill prefix cancelled"))
  371.       (progn (setq *fill-prefix*
  372.                    (buffer-substring b (bpos b) (buffer-line-start b)))
  373.              (set-mini-buffer window "Fill prefix set to ~S." *fill-prefix*)
  374.              (when (> (length *fill-prefix*) *fill-column*)
  375.                (setq *fill-column* (length *fill-prefix*))
  376.                (format (ccl::view-mini-buffer window)
  377.                        "  (Fill column extended to ~S.)" *fill-column*))
  378.              ))))
  379.  
  380. ;;; From my Fred file (with the name changed).  I use this to set Fred key
  381. ;;; bindings so I'll know if I'm replacing anything.
  382. (defun set-command (comtab keystroke function &optional doc replace)
  383.   (let ((old-function (comtab-get-key comtab keystroke)))
  384.     (unless (or replace                 ; "Just do it, dammit!"
  385.                 (null old-function)     ; Not bound
  386.                 (null function)         ; Unsetting a binding
  387.                 (eq old-function function))   ; No change
  388.       (cerror "Install the new command binding anyway."
  389.               "About to replace command binding for ~A with ~S.~@
  390.                  It is currently bound to ~S."
  391.               (ccl::keystroke-code-string keystroke) function old-function)))
  392.   (comtab-set-key comtab keystroke function doc)
  393.   keystroke)
  394.  
  395. (set-command *control-x-comtab* #\. 'ed-set-fill-prefix
  396.   "Set the fill prefix to the text between the cursor and the left margin.")
  397.  
  398. (defmethod ed-set-fill-column ((w fred-mixin))
  399.   (setq *fill-column* (max 1 (if *numeric-arg*
  400.                                (if (consp *numeric-arg*)
  401.                                  *default-fill-column*
  402.                                  *numeric-arg*)
  403.                                (buffer-column (fred-buffer w)))))
  404.   (set-mini-buffer w "Fill column set to ~S." *fill-column*))
  405.  
  406. (set-command *control-x-comtab* #\f 'ed-set-fill-column)
  407.  
  408.  
  409. ;;; The basic method here is to move forward a word at a time and if we go
  410. ;;; past the fill-column then fill, or if we encounter a #\Return before
  411. ;;; reaching the fill-column then unfill.  An alternate method (probably
  412. ;;; faster) would be to move down a line at a time not checking between each
  413. ;;; pair of words, but then it couldn't regularize the spacing between words.
  414. (defmethod ed-fill-paragraph ((window fred-mixin))
  415.   (when (and *fill-column*
  416.              (> *fill-column* 0))
  417.     (let* ((b (fred-buffer window))
  418.            (*fill-prefix* (fill-prefix b (bpos b))))
  419.       (multiple-value-bind (ppstart ppend) (paragraph-bounds window)
  420.          (fill-text window ppstart ppend)))))
  421.  
  422. (defun fill-text (window ppstart ppend)
  423.   (let* ((b (make-mark (fred-buffer window)
  424.                        (buffer-size (fred-buffer window)))))
  425.     (if (or (stringp ppstart)
  426.             (not (and ppstart ppend)))
  427.       ;; Also remember to punt here if fill-column is <= fill-prefix...
  428.       (progn (ed-beep)
  429.              (set-mini-buffer window (or ppstart
  430.                                          "The cursor is not in fillable text.")))
  431.       ;; The vars in this let* are buffer marks so that they have a chance
  432.       ;; of remaining correct even if functions called by fill-text modify
  433.       ;; the buffer.
  434.       (let* ((ppend (make-mark b ppend))
  435.              (eopw (make-mark b ppstart))
  436.              (bow (make-mark b))
  437.              (eow (make-mark b))
  438.              (original-text (buffer-substring b ppstart ppend))         ; for Undo
  439.              (style-vector (buffer-get-style b ppstart ppend))          ; for Undo
  440.              kludge)
  441.         ;; Maybe insert the fill prefix on the first line of the fill
  442.         ;; region.
  443.         (unless (or (/= 0 (buffer-column b ppstart))
  444.                     (fill-prefix-exists-p b ppstart))
  445.           (insert-fill-prefix b ppstart nil))
  446.         (loop until (> (bpos eopw) (bpos ppend))
  447.               as bowpos = (find-next-word b (bpos eopw) (bpos ppend))
  448.               ;; Stop only when the *beginning* of a word is outside the
  449.               ;; fill region.  If a word is partially in the fill region we
  450.               ;; should fill it.
  451.               until (or (null bowpos)
  452.                         (>= bowpos (bpos ppend)))
  453.               do
  454.               (set-mark bow bowpos)
  455.               (set-mark eow (or (buffer-char-pos b *fill-whitespace&cr*
  456.                                                  :start bow :end ppend)
  457.                                 (buffer-line-end bow)))
  458.               (cond ((and (> (buffer-column eow) *fill-column*)
  459.                           ;; The current word juts out past the fill column.
  460.                           (let ((fp-length (fill-prefix-length b (bpos eow))))
  461.                             (or (< (+ (- (bpos eow) (bpos bow)) fp-length)
  462.                                    *fill-column*)
  463.                                 (not (= (buffer-column bow) fp-length)))))
  464.                      ;; The current word juts out past the fill column (and
  465.                      ;; it isn't too big, in combination with the
  466.                      ;; fill-prefix, to be filled, or it is too big, but it
  467.                      ;; isn't on a line by itself).
  468.                      (buffer-delete b eopw bow)
  469.                      (let ((save (bpos eopw)))
  470.                        (insert-fill-prefix eopw (bpos eopw) t)
  471.                        ;; Justify the previous line if *fill-justification*.
  472.                        (justify-one-line b save))
  473.                      )
  474.  
  475.                     ;; If this word fits on the previous line then unfill.
  476.                     ;; This always deletes the text between the end of one
  477.                     ;; line and the first word on the next line because
  478.                     ;; there might be extra blankspace at the beginning of
  479.                     ;; the line.  If that was the case, then a #\Return is
  480.                     ;; inserted again (with the fill prefix).  Probably not
  481.                     ;; the most efficient, but effective.
  482.                     ((< (buffer-line-end eopw) (bpos bow))
  483.                      (buffer-delete b eopw bow)
  484.                      (when (> (bpos eopw) 0)    ; i.e., a previous line exists.
  485.                        (let ((end-of-sentence?
  486.                               (member (buffer-char b (- (bpos eopw) 1))
  487.                                       *fill-sentence-delimiters*
  488.                                       :test #'char=)))
  489.                          (if (<= (+ (buffer-column eopw)        ; column...
  490.                                     (- (bpos eow) (bpos bow))   ; + word size...
  491.                                     (if end-of-sentence? 2 1))  ; + blankspace...
  492.                                  *fill-column*)
  493.                            (buffer-insert b (if end-of-sentence? "  " " ") eopw)
  494.                            (let ((save (bpos eopw)))
  495.                              (insert-fill-prefix b (bpos eopw) t)
  496.                              (justify-one-line b save))
  497.                            ))))
  498.                     ;; Regularize spacing between words.
  499.                     ((and (> (- (bpos bow) (bpos eopw)) 1)
  500.                           (> (bpos eopw) ppstart)
  501.                           (or (not (setq kludge         ; to avoid recomputing...
  502.                                          (member (buffer-char b (- (bpos eopw) 1))
  503.                                                  *fill-sentence-delimiters*
  504.                                                  :test #'char=)))
  505.                               (> (- (bpos bow) (bpos eopw)) 2)))
  506.                      (buffer-delete b eopw bow)
  507.                      (buffer-insert eopw (if kludge "  " " "))
  508.                      ))
  509.               while (< (bpos eow) (buffer-size b))
  510.               do (set-mark eopw (bpos eow))
  511.               ) ;; end main loop
  512.         ;; Setup something to undo the fill.  This should save the cursor
  513.         ;; position.
  514.         (setup-undo window
  515.                     #'(lambda ()
  516.                         (buffer-delete b ppstart (bpos ppend))
  517.                         (buffer-insert-with-style b original-text style-vector ppstart)
  518.                         (fred-update window)
  519.                         ;; Could put Redo code here, but I won't bother yet,
  520.                         ;; since in theory the user can just type m-Q again.
  521.                         )
  522.                     "Undo Fill")
  523.         ))))
  524.  
  525. (set-command *comtab* '(:meta #\q) 'ed-fill-paragraph)
  526.  
  527. ;;; Auto-fill Lisp comments.  This makes no attempt to auto-fill regular
  528. ;;; text, since I don't know of a reliable way to determine whether we're in
  529. ;;; text or Lisp code.  For that matter, lines that begin with semicolons
  530. ;;; aren't necessarily comments either...foo.
  531. (defmethod ed-self-insert :around ((window fred-window))
  532.   (let ((b (fred-buffer window)))
  533.     (when (and *auto-fill-enabled*
  534.                *fill-column*
  535.                (characterp *current-character*)   ; Can this be NIL?
  536.                (member *current-character* '(#\Return #\Space))
  537.                (> (buffer-column b) *fill-column*)
  538.                (or (not (eql *auto-fill-enabled* :lisp-comments))
  539.                    (in-lisp-comment-p b)))   ; most expensive test last.
  540.       (let ((*fill-prefix* 'lisp-comment-fill-prefix))
  541.         ;; Might want to skip over the fill-prefix at the beginning of the line
  542.         ;; first, if any.
  543.         (fill-text window (buffer-line-start b) (bpos b))))
  544.     (call-next-method window)))
  545.  
  546. ;;; The line to be justified is assumed to have the current fill prefix at
  547. ;;; its beginning.
  548. (defun justify-one-line (buffer &optional (position (bpos buffer))
  549.                                    &key direction justification-type)
  550.   ;; Remove whitespace from eol. Find bol (after prefix if any). Remove
  551.   ;; whitespace from bol (unless right justifying).  Insert the appropriate
  552.   ;; number of space chars.
  553.   (when (or justification-type *fill-justification*)
  554.     (let* ((eol (buffer-line-end buffer position))
  555.            (bol (buffer-line-start buffer position))
  556.            (left-margin (skip-over-fill-prefix buffer bol eol))
  557.            (right-margin (let ((rm (skip-whitespace buffer bol eol nil :from-end)))
  558.                            (and rm (+ rm 1))))
  559.            (first-word (skip-whitespace buffer left-margin eol)))
  560.       ;; Justify between left-margin and right-margin.
  561.       (when (and right-margin (< left-margin right-margin)
  562.                  first-word             ; Is this line blank?
  563.                  (< first-word right-margin)
  564.                  (< (- (buffer-column buffer right-margin)
  565.                        (buffer-column buffer first-word))
  566.                     *fill-column*))
  567.         (when (> eol right-margin)        ; Remove whitespace from end of line.
  568.           (buffer-delete buffer right-margin eol))
  569.         (setq left-margin (make-mark buffer left-margin))
  570.         (setq right-margin (make-mark buffer right-margin))
  571.         (when (> first-word (bpos left-margin))
  572.           (buffer-delete buffer (bpos left-margin) first-word))
  573.         (let ((n (- *fill-column* (buffer-column right-margin))))
  574.           (case (or justification-type *fill-justification*)
  575.             (:center
  576.              ;; Insert ~half the spaces just after the fill prefix.
  577.              (dotimes (i (floor n 2))
  578.                (buffer-insert left-margin #\Space)))
  579.             (:right
  580.              ;; Just insert all the spaces directly after the fill prefix.
  581.              (dotimes (i n)
  582.                (buffer-insert left-margin #\Space)))
  583.             (:left
  584.              ;; Just remove all spaces from directly after the fill prefix.
  585.              ;; Already done, above.
  586.              )
  587.             (:full
  588.              ;; Move back and forth across the line and insert spaces until
  589.              ;; the line is justified.  Most of the time this will probably
  590.              ;; only go one direction before inserting all the necessary
  591.              ;; spaces.  First, left justify: Already done, above.
  592.              #+ignore
  593.              (justify-one-line buffer position :direction direction
  594.                                :justification-type :left)
  595.              (loop with x = n
  596.                    until (zerop x)
  597.                    with start = (make-mark left-margin)
  598.                    and end = (make-mark right-margin) do
  599.                    ;; Find next whitespace.
  600.                    (let ((next (buffer-char-pos buffer *fill-whitespace*
  601.                                                 :start (bpos start)
  602.                                                 :end (bpos end)
  603.                                                 :from-end (not direction))))
  604.                      (cond ((and (null next) (= x n))
  605.                             (return nil))
  606.                            ((and next (< (bpos start) next (bpos end)))
  607.                             (buffer-insert buffer #\Space next)
  608.                             (decf x)
  609.                             ;; Move over this whitespace to the next word.
  610.                             (let ((pos (if direction
  611.                                          (skip-whitespace buffer (+ 1 next)
  612.                                                           (bpos end))
  613.                                          (skip-whitespace buffer start next nil :from-end))))
  614.                               (and pos (set-mark (if direction start end) pos))))
  615.                            (t
  616.                             (setq direction (not direction))
  617.                             (set-mark start (bpos left-margin))
  618.                             (set-mark end (bpos right-margin)))))))
  619.             ))))))
  620.  
  621. (defmethod ed-justify-paragraph ((window fred-mixin))
  622.   (multiple-value-bind (ppstart ppend) (paragraph-bounds window)
  623.     (when (and ppstart ppend (< ppstart ppend))
  624.       (loop with bmark = (make-mark (fred-buffer window) ppstart)
  625.             and direction = t
  626.             do (progn (justify-one-line bmark nil :direction direction
  627.                                         :justification-type (or *fill-justification*
  628.                                                                 :FULL))
  629.                       (set-mark bmark (buffer-line-start bmark nil 1))
  630.                       (setq direction (not direction)))
  631.             until (>= (bpos bmark) ppend)))))
  632.  
  633. (set-command *control-x-comtab* #\j 'ed-justify-paragraph)
  634.  
  635.